BMUG PD-ROM 1995 Fall/PD-ROM F95.toast/Utilities/Text Utils/Alpha 5.81 ƒ/Tcl/UserCode/MacPerl.tcl

Text File | 1994-06-12 | 15.3 KB | 528 lines | [TEXT/ALFA]

#############################################################################
# MacPerl.tcl
#
# This is a set of routines that allow Alpha to act as a front end for the
# standalone MacPerl application and that allows Perl scripts to be used as
# text filters in Alpha.
#
#     !!!  This package requires Alpha version 5.75 or higher  !!!
#
#############################################################################
# Features:
#
# A Perl menu is created that allows the following actions:
#
# 1.  Selected text (or the entire buffer) may be interpreted as a Perl
#     script by MacPerl.
#
# 2.  A selected Perl script file may be executed by MacPerl.
#
# 3.  Perl scripts that read from standard input and write to standard
#     output my be used as text filters within Alpha.
#
#     A submenu of "preattached" Perl scripts is constructed from the
#     contents of a "Text Filters" folder within the main MacPerl folder.
#     This folder will be created if it doesn't already exist.
#
#     Besides the "preattached" filters, a disk file or an Alpha buffer
#     which contains a Perl script may be chosen as the text filter.
#     (The latter option allows simple one-time scripts to be created and
#     applied on the fly.  This can be very useful because, even
#     with the overhead to start up MacPerl, large-scale global search-
#     and-replace operations (hundreds of replaces) are substantially faster
#     in MacPerl than in Alpha.)
#
#     The output of Perl text filters may be chosen to overwrite the
#     selected Alpha text or else written into a new window.  (Everything
#     is undoable, in any case).
#
#     The filter may be applied either to the currently selected text
#     or to the entire buffer.
#
# 4.  The temporary i/o files used by the text filter mechanism may be
#     examined.
#
# 5.  The Perl menu may be rebuilt, in case files are added or removed
#     from the "Text Filters" folder.
#
#############################################################################
# Installation:
#
# This file must be placed in the folder where you keep local Tcl
# procedures.  The following lines should be added to your
# 'userStartup.tcl' file (in the Alpha home directory), with the
# appropriate path names for your own system.
#
#     set macperlPath "Macintosh HD:Programming:MacPerl ƒ:MacPerl"
#     source  ":Tcl:Local:MacPerl.tcl"
#
# A sampling of useful :-) Perl scripts are included in the folder "Text Filters".
# You should drag this folder into your MacPerl folder, where MacPerl.tcl will
# look for it.  The "Text Munging" scripts are largely from the Nutshell book
# ("Programming Perl") and the s2p script is my adaptation of the standard script
# that converts Unix "sed" scripts to Perl.  The others may be useful examples,
# as well.
#
# ...........................................................................
#
# If you don't already have MacPerl, it's available by anonymous ftp from
# a number of sites, of which the most accessible seem to be
#
#  grind.isca.uiowa.edu [128.255.21.233]
#                                 mac/umich/development/languages/macperl4.12.sit
#
#  nic.switch.ch [130.59.1.40]    software/mac/perl/Mac_Perl_412_appl.sit.bin
#
#############################################################################
# Authors: W. Thomas Pollard ([e-mail])
#          Martijn Koster ([e-mail])
#
# Version History:
#
# 0.7  3/94 WTP -  nested Text Filters folder now supported
#                  menu format modified somewhat
# 0.6  3/94 WTP -  'applyToBuffer' flag added
#                  scripts in Alpha buffers can now be used as filters
# 0.5  2/94 WTP -  'filters', 'open special' submenu added
#                  'overwrite' flag added
# 0.2  1/94 MK  -  menu support added
#                  'execute selection', 'execute buffer' commands added
# 0.1  9/93 WTP -  text filter functionality created
#
#############################################################################

global perlMenu macperlPath perlOverwrite perlUsebuffer

set perlOverwrite 1
set perlUsebuffer 1

#############################################################################
#  Return paths to standard files, based on the path to MacPerl:
#  (This should make it easier to move MacPerl, install new versions,
#  etc., without breaking the scripts.
#
proc macperlFolder {} {
   global macperlPath
   regexp {(.*):([^:]*)} $macperlPath pathname dirname filename
   return ${dirname}:
}

proc stdinPath {} {
   return [macperlFolder]STDIN
}

proc stdoutPath {} {
   return [macperlFolder]STDOUT
}

proc scriptPath {} {
   return [macperlFolder]SCRIPT
}

proc scriptFolder {} {
   return "[macperlFolder]Text Filters:"
}

#############################################################################
#  Set the "overwrite" flag.  If true, then the output of a Perl filter
#  is inserted in place of the originally selected text.  Otherwise, it is
#  placed in a new window.  The names of the routines reflect the condition
#  of the flag _before_ the routine is called, so that the menu makes more
#  sense.
#
proc •OverwriteSelection {} {
    global perlOverwrite
    set perlOverwrite 0
    rebuildPerlMenu
}

proc •Don\'tOverwriteSelection {} {
    global perlOverwrite
    set perlOverwrite 1
    rebuildPerlMenu
}

#############################################################################
#  Set the "usebuffer" flag.  If true, then the Perl filter is applied to
#  the entire buffer.  Otherwise, only the selected text is filtered.
#
proc •ApplyToBuffer {} {
    global perlUsebuffer
    set perlUsebuffer 0
    rebuildPerlMenu
}

proc •ApplyToSelection {} {
    global perlUsebuffer
    set perlUsebuffer 1
    rebuildPerlMenu
}

#############################################################################
#  This is a generally useful proc that builds a hierarchical menu
#  from the files in a given folder and all subfolders.  As the menu is
#  built, the pathnames of the various files are saved in the array
#  indicated  by $filePaths.  The index of the file's path in this array
#  is formed by concatenating the submenu name and filename, allowing the
#  pathname to be retrieved by the procedure $proc when the menu item is
#  selected.
#
proc buildSubMenu {folder name proc filePaths} {
    global $filePaths
    if {$name == 0} {
        set name [file tail [file dirname $folder]]
    }
    if {$proc == 0} {
        set pproc ""
    } else {
        set pproc "-p $proc"
    }
    set menu {}
    set filenames [glob -nocomplain  $folder\*]
    if {[llength $filenames] > 0} {
       foreach m $filenames {
          if {[file isdirectory $m]} {
              lappend menu [buildSubMenu ${m}: 0 $proc $filePaths]
          } elseif {[file isfile $m]} {
              set fname [file tail $m]
              lappend menu $fname
              set ${filePaths}($name:$fname) $m
          }
         }
    }
    return [concat {menu -m -n} [list $name] $pproc [list $menu]]
}

#############################################################################
#  Build a submenu of "preattached" Perl filters using the names of the
#  scripts in the Text Filters directory
#
proc perlFilterMenu {} {
    global perlFilterPath HOME
    set scriptDir [scriptFolder]
    if {![file exists $scriptDir]} {
       cpdir "$HOME:Tcl:UserCode:Text Filters" [macperlFolder]
       alertnote "Created \"[macperlFolder]Text Filters\" folder."
    }
    return [buildSubMenu $scriptDir TextFilters perlExecuteFilter perlFilterPath]
}

proc rebuildPerlMenu {} {
    global perlMenu perlOverwrite perlUsebuffer

    if {$perlOverwrite} {
            set overwriteItem •OverwriteSelection
        } else {
            set overwriteItem •Don\'tOverwriteSelection
        }

    if {$perlUsebuffer} {
            set usebufferItem •ApplyToBuffer
        } else {
            set usebufferItem •ApplyToSelection
        }

    menu -n $perlMenu [ concat {
        "macperl"
        "(-"
        "runTheSelection"
        "runTheBuffer"
        "runAFile"
        "(-"
        } [list [perlFilterMenu]] {
        {menu -n OtherTextFilters {
           "selectABuffer"
           "selectAFile"
           }
        }
        } $overwriteItem  {
        } $usebufferItem  {
        "(-"
        {menu -m -n openSpecial -p perlOpenFile {
           "STDIN"
           "STDOUT"
           "SCRIPT"
           }
        }
        "(-"
        "rebuildPerlMenu"
        } ]

    removeMenu $perlMenu
    insertMenu $perlMenu
}

rebuildPerlMenu

#############################################################################
# Switch to MacPerl:
#
proc macperl {} {
    global macperlPath
    set name [checkRunning MacPerl McPL macperlPath]
    if {[string length $name]} {
        switchTo "MacPerl"
    } else {
        alertnote "Couldn't run MacPerl"
    }
}

#############################################################################
#
proc perlOpenFile {menu name} {
    set filename [macperlFolder]$name
    if {[file exists $filename]} {
        edit $filename
    } else {
        alertnote "That file doesn't exist yet"
    }
}

#############################################################################
# Get a script file to run under MacPerl:
#
proc runAFile {} {
    if {! [catch {getfile "Select a Perl script:"} path]} {
            perlExecuteFile $path
    }
}

#############################################################################
# Tell MacPerl to run a script file:
#
proc ExecuteFile {path} {
    global macperlPath
    if {[string length $path]} {
        set name [checkRunning MacPerl McPL macperlPath]
        if {[string length $name]} {
            dosc -c 'McPL' -r -f $path
            switchTo "MacPerl"
        } else {
            alertnote "Couldn't run MacPerl"
        }
    } else {
            alertnote "No file specified to execute"
    }
}

#############################################################################
# Run the buffer as a MacPerl script:
#
proc runTheBuffer {} {
    perlExecuteScript [getText 0 [maxPos]]
}

#############################################################################
# Run the selection as a MacPerl script:
# (No special arrangements are made to provide input or capture the output)
#
proc runTheSelection {} {
    completeSelection
    perlExecuteScript [getSelect]
}

#############################################################################
# Run a MacPerl script file.
# (No special arrangements are made to provide input or capture the output)
#
proc perlExecuteFile {fname} {
    set fd [open $fname "r"]
    perlExecuteScript [read $fd]
    close $fd
}

#############################################################################
# Run a MacPerl script, passed explicitly as a string:
# (No special arrangements are made to provide input or capture the output)
#
proc perlExecuteScript {script} {
    global macperlPath
    if {$script != ""} {
        set name [checkRunning MacPerl McPL macperlPath]
        if {[string length $name]} {
            dosc -c 'McPL' -r -s $script
            switchTo "MacPerl"
       } else {
            alertnote "Couldn't run MacPerl"
       }
    } else {
        alertnote "Empty script"
    }
}

#############################################################################
# Run a Perl script filter selected from the menu:
#
proc perlExecuteFilter {menu name} {
    global perlFilterPath
    set path $perlFilterPath($menu:$name)
#    set path [scriptFolder]$name
    set coreScript [readFile $path]
    if {$coreScript != -1} {
        set script [wrapFilterScript $coreScript]
        filterThruMacperl $script
    } else {
        alertnote "Couldn't read the script file : $path"
        return
    }
}

#############################################################################
# Ask for a file containing a Perl script to use as a filter:
#
proc selectAFile {} {
    if {! [catch {getfile "Select a MacPerl script"} path]} {
        set coreScript [readFile $path]
        if {$coreScript != -1} {
            set script [wrapFilterScript $coreScript]
            filterThruMacperl $script
        } else {
            alertnote "Couldn't read the script file : $path"
            return
        }
    }
}

#############################################################################
# Ask for an Alpha buffer containing a Perl script to use as a filter:
#
proc selectABuffer {} {
    set windows [winNames]
    if {[llength $windows] > 1} {
        set current [lindex $windows 0]
        set name [listpick [lsort $windows]]
        if {[string length $name]} {
            bringToFront $name
            set coreScript [getText 0 [maxPos]]
            if {[string length $coreScript]} {
                set script [wrapFilterScript $coreScript]
                bringToFront $current
                filterThruMacperl $script
            } else {
                bringToFront $current
            }
           }
    }
}

#############################################################################
# Filter selection through a Perl script:
#
# bugs:  If the script contains an existing !/bin/perl line, then it
#        should be removed, or preferably used instead of my own new line.
#
proc filterThruMacperl {script} {
    global macperlPath perlOverwrite perlUsebuffer

    set name [checkRunning MacPerl McPL macperlPath]
    if {[string length $name]} {
        writeStdin
        writeStdout
        dosc -c 'McPL' -t 0 -s $script
    } else {
        alertnote "Couldn't run MacPerl"
    }

    if {!$perlOverwrite} new
    if {$perlUsebuffer} {
        pasteStdout 0 [maxPos]
    } else {
        pasteStdout [getPos] [selEnd]
    }
}

#############################################################################
#  Take a Perl script and add commands to take the file STDIN as standard
#  input and STDOUT as standard output.  This allows scripts written as
#  Unix command-line filters to be used in the (non-MPW) Mac environment as
#  text filters.
#
proc wrapFilterScript {coreScript} {

    set filterHead "#!/usr/bin/perl\n"
    append filterHead "\$macperlDir = \"[macperlFolder]\" ;\n"
    append filterHead "open(STDIN, \"<[stdinPath]\" ) ;\n"
    append filterHead "open(STDOUT, \">[stdoutPath]\" ) ;\n"
    append filterHead "@ARGV = (\"[stdinPath]\") ;\n"
    append filterHead "select(STDOUT) ;\n\n"

    set filterTail "close STDIN ;\nclose STDOUT ;\n"

    set script $filterHead
    append script $coreScript
    append script $filterTail

    writeScript $script
    return $script
}

#############################################################################
#  Paste the text of the file STDOUT in place of the current selection.
#
proc pasteStdout {from to} {
    set result [readFile [stdoutPath]]
    if {$result != -1} {
        deleteText $from $to
        insertText $result
        shrinkLow
        goto 0
    } else {
        alertnote "Couldn't find the output file : STDOUT"
    }
}
#        replaceText [getPos] [selEnd] $result

#############################################################################
#  Extend the current selection to encompass complete lines.
#
proc completeSelection {} {
    global perlUsebuffer
    if {$perlUsebuffer} {
        set start 0
        set end [maxPos]
    } else {
        set start [lineStart [getPos]]
        set end [nextLineStart [expr [selEnd]-1]]
    }
    if {$end == $start} {set end [nextLineStart [selEnd]]}
    select $start $end
}

#############################################################################
#
proc writeStdin {} {
    completeSelection
    set tmpfid [open [stdinPath] "w+"]
    puts $tmpfid [getSelect]
    close $tmpfid
}

proc writeStdout {} {
    completeSelection
    set tmpfid [open [stdoutPath] "w+"]
    puts $tmpfid [getSelect]
    close $tmpfid
}

proc writeScript {script} {
    set tmpfid [open [scriptPath] "w+"]
    puts $tmpfid $script
    close $tmpfid
}

#############################################################################
#
proc readFile {fileName} {
    if {[file exists $fileName] && [file readable $fileName]} {
       set fileid [open $fileName "r"]
       set contents ""
       while {[gets $fileid nextLine] != -1} {
          append contents $nextLine "\n"
       }
       close $fileid
       return $contents
    } else {
       return -1
    }
}